home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / efs / dired-cmpr.el.z / dired-cmpr.el
Encoding:
Text File  |  1998-05-21  |  9.7 KB  |  316 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;
  3. ;; File:          dired-cmpr.el
  4. ;; Dired Version: #Revision: 7.9 $
  5. ;; RCS:
  6. ;; Description:   Commands for compressing marked files.
  7. ;;
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9.  
  10. ;;; Requirements and provisions
  11. (provide 'dired-cmpr)
  12. (require 'dired)
  13.  
  14. ;;; Entry points.
  15.  
  16. (defun dired-do-compress (&optional arg files)
  17.   "Compress or uncompress marked (or next ARG) files.
  18. With a zero prefix, prompts for a new value of `dired-compression-method'."
  19.   (interactive
  20.    (let ((arg (prefix-numeric-value current-prefix-arg))
  21.      files)
  22.      (if (zerop arg)
  23.      (let ((new (completing-read
  24.              (format "Set compression method (currently %s): "
  25.                  dired-compression-method)
  26.              (mapcar
  27.               (function
  28.                (lambda (x)
  29.              (cons (symbol-name (car x)) nil)))
  30.               dired-compression-method-alist)
  31.              nil t)))
  32.        (or (string-equal new "")
  33.            (setq dired-compression-method (intern new))))
  34.        (setq files (dired-get-marked-files nil current-prefix-arg))
  35.        (or (memq 'compress dired-no-confirm)
  36.        (let* ((dir (dired-current-directory))
  37.           (rfiles (mapcar (function
  38.                    (lambda (fn)
  39.                      (dired-make-relative fn dir t)))
  40.                     files))
  41.           (prompt "")
  42.           (comp 0)
  43.           (uncomp nil)
  44.           (total (length files))
  45.           elt)
  46.          (mapcar (function
  47.               (lambda (fn)
  48.             (if (listp (setq elt
  49.                      (dired-make-compressed-filename fn)))
  50.                 (let* ((method (car (nth 3 elt)))
  51.                    (count (assoc method uncomp)))
  52.                   (if count
  53.                   (setcdr count (1+ (cdr count)))
  54.                 (setq uncomp (cons (cons method 1) uncomp))))
  55.               (setq comp (1+ comp)))))
  56.              files)
  57.          (if (/= comp 0)
  58.          (setq prompt
  59.                (format "%s %d"
  60.                    (car
  61.                 (nth 2
  62.                      (assq dired-compression-method
  63.                        dired-compression-method-alist)))
  64.                    comp)))
  65.          (if uncomp
  66.          (let ((case-fold-search t)
  67.                method)
  68.            (or (string-equal prompt "")
  69.                (setq prompt (concat prompt "; ")))
  70.            (setq uncomp
  71.              (sort
  72.               (mapcar
  73.                (function
  74.                 (lambda (elt)
  75.                   (setq method (car elt))
  76.                   (if (string-equal method "gzip")
  77.                   (setq method "gunzip")
  78.                 (or (string-match "^un" method)
  79.                     (setq method (concat "un" method))))
  80.                   (setcar elt method)
  81.                   elt))
  82.                uncomp)
  83.               (function
  84.                (lambda (x y)
  85.                  (string< (car x) (car y))))))
  86.            (setq prompt
  87.              (concat prompt
  88.                  (mapconcat
  89.                   (function
  90.                    (lambda (elt)
  91.                      (format "%s %d" (car elt) (cdr elt))))
  92.                   uncomp ", ")))))
  93.          (cond
  94.           ((= (length rfiles) 1)
  95.            (setq prompt (format "%s %s? "
  96.                     ;; Don't need the number 1
  97.                     (substring prompt 0 -2)
  98.                     (car rfiles))))
  99.           ((or (> (length uncomp) 1) (and (/= 0 comp) uncomp))
  100.            (setq prompt (format "%s? Total: %d file%s " prompt total
  101.                     (dired-plural-s total))))
  102.           ((setq prompt (format "%s file%s? " prompt
  103.                     (dired-plural-s total)))))
  104.          (or (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt)
  105.          (setq arg 0)))))
  106.      (list arg files)))
  107.        
  108.   (if (not (zerop arg))
  109.       (dired-create-files
  110.        'dired-compress-file
  111.        "Compress or Uncompress"
  112.        files
  113.        (function
  114.     (lambda (fn)
  115.       (let ((cfn (dired-make-compressed-filename fn)))
  116.         (if (stringp cfn)
  117.         cfn
  118.           (substring fn 0 (- (length (nth 1 cfn))))))))
  119.        dired-keep-marker-compress nil t)))
  120.  
  121. (defun dired-compress-subdir-files (&optional uncompress)
  122.   "Compress all uncompressed files in the current subdirectory.
  123. With a prefix argument uncompresses all compressed files."
  124.   (interactive "P")
  125.   (let ((dir (dired-current-directory))
  126.     files methods uncomp elt)
  127.     (save-excursion
  128.       (save-restriction
  129.     (narrow-to-region (dired-subdir-min) (dired-subdir-max))
  130.     (dired-map-dired-file-lines
  131.      (function
  132.       (lambda (f)
  133.         (if uncompress
  134.         (and (listp (setq uncomp (dired-make-compressed-filename f)))
  135.              (let ((program (car (nth 3 uncomp))))
  136.                (setq files (cons f files))
  137.                (if (setq elt (assoc program methods))
  138.                (setcdr elt (1+ (cdr elt)))
  139.              (setq methods (cons (cons program 1) methods)))))
  140.           (and (stringp (dired-make-compressed-filename f))
  141.            (setq files (cons f files)))))))))
  142.     (if files
  143.     (let ((total (length files))
  144.           (rfiles (mapcar
  145.                (function
  146.             (lambda (fn)
  147.               (dired-make-relative fn dir t)))
  148.                files))
  149.           prompt)
  150.       (if uncompress
  151.           (progn
  152.         (setq prompt (mapconcat
  153.                   (function
  154.                    (lambda (x)
  155.                  (format "%s %d"
  156.                      (if (string-equal (car x) "gzip")
  157.                          "gunzip"
  158.                        (if (string-match "^un" (car x))
  159.                            (car x)
  160.                          (concat "un" (car x))))
  161.                      (cdr x))))
  162.                   methods ", "))
  163.         (cond
  164.          ((= total 1)
  165.           (setq prompt
  166.             (concat (substring prompt 0 -1) (car rfiles) "? ")))
  167.          ((= (length methods) 1)
  168.           (setq prompt
  169.             (format "%s file%s? " prompt (dired-plural-s total))))
  170.          (t
  171.           (setq prompt (format "%s? Total: %d file%s " prompt total
  172.                        (dired-plural-s total))))))
  173.         (setq prompt
  174.           (if (= total 1)
  175.               (format "%s %s? " dired-compression-method (car rfiles))
  176.             (format "%s %d file%s? "
  177.                 dired-compression-method total
  178.                 (dired-plural-s total)))))
  179.       (if (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt)
  180.           (dired-create-files
  181.            'dired-compress-file
  182.            "Compress or Uncompress"
  183.            files
  184.            (function
  185.         (lambda (fn)
  186.           (let ((cfn (dired-make-compressed-filename fn)))
  187.             (if (stringp cfn)
  188.             cfn
  189.               (substring fn 0 (- (length (nth 1 cfn))))))))
  190.            dired-keep-marker-compress nil t)))
  191.       (message "No files need %scompressing in %s."
  192.            (if uncompress "un" "")
  193.            (dired-abbreviate-file-name dir)))))
  194.  
  195. (defun dired-compress-file (file ok-flag)
  196.   ;; Compress or uncompress FILE.
  197.   ;; If ok-flag is non-nil, it is OK to overwrite an existing
  198.   ;; file. How well this actually works may depend on the compression
  199.   ;; program.
  200.   ;; Return the name of the compressed or uncompressed file.
  201.   (let ((handler (find-file-name-handler file 'dired-compress-file)))
  202.     (if handler
  203.     (funcall handler 'dired-compress-file file ok-flag)
  204.       (let ((compressed-fn (dired-make-compressed-filename file))
  205.         (err-buff (get-buffer-create " *dired-check-process output*")))
  206.     (save-excursion
  207.       (set-buffer err-buff)
  208.       (erase-buffer)
  209.       (cond ((file-symlink-p file)
  210.          (signal 'file-error (list "Error compressing file"
  211.                        file "a symbolic link")))
  212.         ((listp compressed-fn)
  213.          (message "Uncompressing %s..." file)
  214.          (let* ((data (nth 3 compressed-fn))
  215.             (ret
  216.              (apply 'call-process
  217.                 (car data) file t nil
  218.                 (append (cdr data)
  219.                     (and ok-flag
  220.                          (list (nth 4 compressed-fn)))
  221.                     (list file)))))
  222.            (if (or (and (integerp ret) (/= ret 0))
  223.                (not (bobp)))
  224.                (signal 'file-error
  225.                    (nconc
  226.                 (list "Error uncompressing file"
  227.                       file)
  228.                 (and (not (bobp))
  229.                      (list
  230.                       (progn
  231.                     (goto-char (point-min))
  232.                     (buffer-substring
  233.                      (point) (progn (end-of-line)
  234.                             (point))))))))))
  235.          (message "Uncompressing %s...done" file)
  236.          (dired-remove-file file)
  237.          (let ((to (substring file 0
  238.                       (- (length (nth 1 compressed-fn))))))
  239.            ;; rename any buffers
  240.            (and (get-file-buffer file)
  241.             (save-excursion
  242.               (set-buffer (get-file-buffer file))
  243.               (let ((modflag (buffer-modified-p)))
  244.                 ;; kills write-file-hooks
  245.                 (set-visited-file-name to)    
  246.                 (set-buffer-modified-p modflag))))
  247.            to))
  248.         ((stringp compressed-fn)
  249.          (message "Compressing %s..." file)
  250.          (let* ((data (assq dired-compression-method
  251.                     dired-compression-method-alist))
  252.             (compr-args (nth 2 data))
  253.             (ret
  254.              (apply 'call-process
  255.                 (car compr-args) file t nil
  256.                 (append (cdr compr-args)
  257.                     (and ok-flag
  258.                          (list (nth 4 data)))
  259.                     (list file)))))
  260.            (if (or (and (integerp ret) (/= ret 0))
  261.                (not (bobp)))
  262.                (signal 'file-error
  263.                    (nconc
  264.                 (list "Error compressing file"
  265.                       file)
  266.                 (and (not (bobp))
  267.                      (list
  268.                       (progn
  269.                     (goto-char (point-min))
  270.                     (buffer-substring
  271.                      (point) (progn (end-of-line)
  272.                             (point))))))))))
  273.          (message "Compressing %s...done" file)
  274.          (dired-remove-file file)
  275.          ;; rename any buffers
  276.          (and (get-file-buffer file)
  277.               (save-excursion
  278.             (set-buffer (get-file-buffer file))
  279.             (let ((modflag (buffer-modified-p)))
  280.               ;; kills write-file-hooks
  281.               (set-visited-file-name compressed-fn)    
  282.               (set-buffer-modified-p modflag))))
  283.          compressed-fn)
  284.         (t (error "Strange error in dired-compress-file."))))))))
  285.  
  286. (defun dired-make-compressed-filename (name &optional method)
  287.   ;; If NAME is in the syntax of a compressed file (according to
  288.   ;; dired-compression-method-alist), return the data (a list) from this
  289.   ;; alist on how to uncompress it. Otherwise, return a string, the
  290.   ;; compressed form of this file name. This is computed using the optional
  291.   ;; argument METHOD (a symbol). If METHOD is nil, the ambient value of
  292.   ;; dired-compression-method is used.
  293.   (let ((handler (find-file-name-handler
  294.           name 'dired-make-compressed-filename)))
  295.     (if handler
  296.     (funcall handler 'dired-make-compressed-filename name method)
  297.       (let ((alist dired-compression-method-alist)
  298.         (len (length name))
  299.         ext ext-len result)
  300.     (while alist
  301.       (if (and (> len
  302.               (setq ext-len (length (setq ext (nth 1 (car alist))))))
  303.            (string-equal ext (substring name (- ext-len))))
  304.           (setq result (car alist)
  305.             alist nil)
  306.         (setq alist (cdr alist))))
  307.     (or result
  308.         (concat name
  309.             (nth 1 (or (assq (or method dired-compression-method)
  310.                      dired-compression-method-alist)
  311.                    (error "Unknown compression method: %s"
  312.                       (or method dired-compression-method))))))
  313.     ))))
  314.  
  315. ;;; end of dired-cmpr.el
  316.